home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / b / b.lha / B / src / bint / b3env.c < prev    next >
C/C++ Source or Header  |  1988-11-24  |  4KB  |  157 lines
  1. /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
  2.  
  3. /*
  4.   $Header: b3env.c,v 1.4 85/08/22 16:57:42 timo Exp $
  5. */
  6.  
  7. /* Environments */
  8.  
  9. #include "b.h"
  10. #include "b1obj.h"
  11. #include "b3err.h" /*for curline, curlino*/
  12.  
  13. Visible envtab prmnvtab;
  14. Visible envchain prmnvchain;
  15. Visible env prmnv;
  16.  
  17. /* context: */
  18. /* The bound tags for the current environment are stored in *bndtgs */
  19. /* A new bound tag list is created on evaluating a refined test or expression */
  20.  
  21. Visible env curnv;
  22. Visible value *bndtgs;
  23. Hidden value bndtglist;
  24. Visible literal cntxt, resexp;
  25. Visible value uname= Vnil;
  26. Visible intlet lino;
  27. Visible intlet f_lino;
  28.  
  29. Visible context read_context;
  30.  
  31. Visible Procedure sv_context(sc) context *sc; {
  32.     sc->curnv= curnv;
  33.     sc->bndtgs= bndtgs;
  34.     sc->cntxt= cntxt;
  35.     sc->resexp= resexp;
  36.     sc->uname= copy(uname);
  37.     sc->cur_line= curline;
  38.     sc->cur_lino= curlino;
  39. }
  40.  
  41. Visible Procedure set_context(sc) context *sc; {
  42.     curnv= sc->curnv;
  43.     bndtgs= sc->bndtgs;
  44.     cntxt= sc->cntxt;
  45.     resexp= sc->resexp;
  46.     release(uname); uname= sc->uname;
  47.     curline= sc->cur_line;
  48.     curlino= sc->cur_lino;
  49. }
  50.  
  51. Visible Procedure initenv() {
  52.     /* The following invariant must be maintained:
  53.        EITHER:
  54.           the original permanent-environment table resides in prmnv->tab
  55.           and prmnvtab == Vnil
  56.        OR:
  57.           the original permanent-environment table resides in prmnvtab
  58.           and prmnv->tab contains a scratch-pad copy.
  59.     */
  60.     prmnv= &prmnvchain;
  61.     prmnv->tab= mk_elt(); prmnvtab= Vnil;
  62.     prmnv->inv_env= Enil;
  63.     bndtglist= mk_elt();
  64. }
  65.  
  66. Visible Procedure endenv() {
  67.     release(prmnv->tab); prmnv->tab= Vnil;
  68.     release(bndtglist); bndtglist= Vnil;
  69.     release(uname); uname= Vnil;
  70.     release(erruname); erruname= Vnil;
  71. }
  72.  
  73. Visible Procedure re_env() {
  74.     setprmnv(); bndtgs= &bndtglist;
  75. }
  76.  
  77. Visible Procedure setprmnv() {
  78.     /* the current and permanent environment are reset
  79.        to the original permanent environment */
  80.     if (prmnvtab != Vnil) {
  81.         prmnv->tab= prmnvtab;
  82.         prmnvtab= Vnil;
  83.     }
  84.     curnv= prmnv;
  85. }
  86.  
  87. Visible Procedure e_replace(v, t, k) value v, *t, k; {
  88.     if (Is_compound(*t)) {
  89.         int n= SmallIntVal(k);
  90.         uniql(t);
  91.         if (*Field(*t, n) != Vnil) release(*Field(*t, n));
  92.         *Field(*t, n)= copy(v);
  93.     }
  94.     else if (!Is_table(*t)) syserr(MESS(2900, "replacing in non-environment"));
  95.     else replace(v, t, k);
  96. }
  97.  
  98. Visible Procedure e_delete(t, k) value *t, k; {
  99.     if (Is_compound(*t) && IsSmallInt(k)) {
  100.         int n= SmallIntVal(k);
  101.         if (*Field(*t, n) != Vnil) {
  102.             uniql(t); release(*Field(*t, n));
  103.             *Field(*t, n)= Vnil;
  104.         }
  105.     }
  106.     else if (!Is_table(*t)) syserr(MESS(2901, "deleting from non-environment"));
  107.     else if (in_keys(k, *t)) delete(t, k);
  108. }
  109.  
  110. Visible value* envassoc(t, ke) value t, ke; {
  111.     if (Is_compound(t) && IsSmallInt(ke)) {
  112.         int n= SmallIntVal(ke);
  113.         if (*Field(t, n) == Vnil) return Pnil;
  114.         return Field(t, n);
  115.     }
  116.     if (!Is_table(t)) syserr(MESS(2902, "selection on non-environment"));
  117.     return adrassoc(t, ke);
  118. }
  119.  
  120. Visible bool in_env(tab, ke, aa) value tab, ke, **aa; {
  121.     /* IF ke in keys tab:
  122.         PUT tab[ke] IN aa
  123.         SUCCEED
  124.        FAIL
  125.     */
  126.     *aa= envassoc(tab, ke);
  127.     return (*aa != Pnil);
  128. }
  129.  
  130. Visible Procedure extbnd_tags(btl, et) value btl; envtab et; {
  131.     /* Copy bound targets to the invoking environment */
  132.     /* FOR tag IN btl: \ btl is the bound tag list
  133.            IF tag in keys et: \ et is the environment we're just leaving
  134.                PUT et[tag] IN curnv[tag] \ curnv is the invoking environment
  135.     */
  136.     value *aa, tag;
  137.     int len= length(btl), k;
  138.     for (k= 1; k <= len; k++) {
  139.         tag= thof(k, btl);
  140.         if (in_env(et, tag, &aa)) {
  141.             e_replace(*aa, &(curnv->tab), tag);
  142.             if (*bndtgs != Vnil) insert(tag, bndtgs);
  143.         }
  144.         release(tag);
  145.     }
  146. }
  147.  
  148. Visible Procedure lst_ttgs() {
  149.     int k, len;
  150.     len= length(prmnv->tab);
  151.     k_Over_len {
  152.         writ(*key(prmnv->tab, k));
  153.         wri_space();
  154.     }
  155.     newline();
  156. }
  157.